home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / random.scm < prev    next >
Text File  |  1999-04-19  |  5KB  |  140 lines
  1. ;;;; "random.scm" Pseudo-Random number generator for scheme.
  2. ;;; Copyright (C) 1991, 1993, 1998, 1999 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'byte)
  21. (require 'logical)
  22.  
  23. ;;; random:chunk returns an integer in the range of 0 to 255.
  24. (define (random:chunk sta)
  25.   (cond ((positive? (byte-ref sta 258))
  26.      (byte-set! sta 258 0)
  27.      (slib:error "random state called reentrantly")))
  28.   (byte-set! sta 258 1)
  29.   (let* ((idx (logand #xff (+ 1 (byte-ref sta 256))))
  30.      (xtm (byte-ref sta idx))
  31.      (idy (logand #xff (+ (byte-ref sta 257) xtm))))
  32.     (byte-set! sta 256 idx)
  33.     (byte-set! sta 257 idy)
  34.     (let ((ytm (byte-ref sta idy)))
  35.       (byte-set! sta idy xtm)
  36.       (byte-set! sta idx ytm)
  37.       (let ((ans (byte-ref sta (logand #xff (+ ytm xtm)))))
  38.     (byte-set! sta 258 0)
  39.     ans))))
  40.  
  41.  
  42. ;;@args n
  43. ;;@args n state
  44. ;;Accepts a positive integer or real @1 and returns a number of the
  45. ;;same type between zero (inclusive) and @1 (exclusive).  The values
  46. ;;returned by @0 are uniformly distributed from 0 to @1.
  47. ;;
  48. ;;The optional argument @var{state} must be of the type returned by
  49. ;;@code{(seed->random-state)} or @code{(make-random-state)}.  It defaults
  50. ;;to the value of the variable @code{*random-state*}.  This object is used
  51. ;;to maintain the state of the pseudo-random-number generator and is
  52. ;;altered as a side effect of calls to @code{random}.
  53. (define (random modu . args)
  54.   (let ((state (if (null? args) *random-state* (car args))))
  55.     (if (exact? modu)
  56.     (letrec ((bitlen (integer-length (+ -1 modu)))
  57.          (rnd (lambda ()
  58.             (do ((bln bitlen (+ -8 bln))
  59.                  (rbs 0 (+ (ash rbs 8) (random:chunk state))))
  60.                 ((<= bln 7)
  61.                  (set! rbs (+ (ash rbs bln)
  62.                       (bit-field (random:chunk state) 0 bln)))
  63.                  (and (< rbs modu) rbs))))))
  64.       (do ((ans (rnd) (rnd))) (ans ans)))
  65.     (* (random:uniform1 state) modu))))
  66.  
  67. (define random:random random)
  68. ;;;random:uniform is in randinex.scm.  It is needed only if inexact is
  69. ;;;supported.
  70.  
  71.  
  72. ;;@defvar *random-state*
  73. ;;Holds a data structure that encodes the internal state of the
  74. ;;random-number generator that @code{random} uses by default.  The nature
  75. ;;of this data structure is implementation-dependent.  It may be printed
  76. ;;out and successfully read back in, but may or may not function correctly
  77. ;;as a random-number state object in another implementation.
  78. ;;@end defvar
  79.  
  80.  
  81. ;;@args state
  82. ;;Returns a new copy of argument @1.
  83. ;;
  84. ;;@args
  85. ;;Returns a new copy of @code{*random-state*}.
  86. (define (copy-random-state . sta)
  87.   (copy-string (if (null? sta) *random-state* (car sta))))
  88.  
  89.  
  90. ;;@body
  91. ;;Returns a new object of type suitable for use as the value of the
  92. ;;variable @code{*random-state*} or as a second argument to @code{random}.
  93. ;;The number or string @1 is used to initialize the state.  If
  94. ;;@0 is called twice with arguments which are
  95. ;;@code{equal?}, then the returned data structures will be @code{equal?}.
  96. ;;Calling @0 with unequal arguments will nearly
  97. ;;always return unequal states.
  98. (define (seed->random-state seed)
  99.   (define sta (make-bytes (+ 3 256) 0))
  100.   (if (number? seed) (set! seed (number->string seed)))
  101.                     ; initialize state
  102.   (do ((idx #xff (+ -1 idx)))
  103.       ((negative? idx))
  104.     (byte-set! sta idx idx))
  105.                     ; merge seed into state
  106.   (do ((i 0 (+ 1 i))
  107.        (j 0 (modulo (+ 1 j) seed-len))
  108.        (seed-len (bytes-length seed))
  109.        (k 0))
  110.       ((>= i 256))
  111.     (let ((swp (byte-ref sta i)))
  112.       (set! k (logand #xff (+ k (byte-ref seed j) swp)))
  113.       (byte-set! sta i (byte-ref sta k))
  114.       (byte-set! sta k swp)))
  115.   sta)
  116.  
  117.  
  118. ;;@args
  119. ;;@args obj
  120. ;;Returns a new object of type suitable for use as the value of the
  121. ;;variable @code{*random-state*} or as a second argument to @code{random}.
  122. ;;If the optional argument @var{obj} is given, it should be a printable
  123. ;;Scheme object; the first 50 characters of its printed representation
  124. ;;will be used as the seed.  Otherwise the value of @code{*random-state*}
  125. ;;is used as the seed.
  126. (define (make-random-state . args)
  127.   (let ((seed (if (null? args) *random-state* (car args))))
  128.     (cond ((string? seed))
  129.       ((number? seed) (set! seed (number->string seed)))
  130.       (else (let ()
  131.           (require 'object->string)
  132.           (set! seed (object->limited-string seed 50)))))
  133.     (seed->random-state seed)))
  134.  
  135. (define *random-state*
  136.   (make-random-state "http://swissnet.ai.mit.edu/~jaffer/SLIB.html"))
  137.  
  138. (provide 'random)            ;to prevent loops
  139. (if (provided? 'inexact) (require 'random-inexact))
  140.